The CICA Windows Explosion!/The CICA Windows Explosion! - Disc 2.iso/programr/vbasic/datamgr.exe/DATAFORM.FRM

Text File | 1993-04-21 | 19KB | 729 lines

VERSION 2.00
Begin Form DataForm
   BackColor       =   &H00C0C0C0&
   ClientHeight    =   3960
   ClientLeft      =   630
   ClientTop       =   1755
   ClientWidth     =   8475
   Height          =   4365
   Icon            =   DATAFORM.FRX:0000
   Left            =   570
   LinkTopic       =   "Form2"
   MDIChild        =   -1  'True
   ScaleHeight     =   3960
   ScaleWidth      =   8475
   Top             =   1410
   Width           =   8595
   Begin PictureBox StatBox
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   270
      Left            =   0
      ScaleHeight     =   282.462
      ScaleMode       =   0  'User
      ScaleWidth      =   8490.27
      TabIndex        =   5
      Top             =   3690
      Width           =   8475
      Begin Data Data1
         Connect         =   ""
         DatabaseName    =   ""
         Exclusive       =   0   'False
         Height          =   270
         Left            =   0
         Options         =   0
         ReadOnly        =   0   'False
         RecordSource    =   ""
         Top             =   0
         Width           =   5475
      End
   End
   Begin VScrollBar cScrollBar
      Height          =   2085
      LargeChange     =   3500
      Left            =   7665
      SmallChange     =   350
      TabIndex        =   14
      Top             =   630
      Visible         =   0   'False
      Width           =   255
   End
   Begin PictureBox cFields
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   1065
      Left            =   0
      ScaleHeight     =   1056.48
      ScaleMode       =   0  'User
      ScaleWidth      =   7600.262
      TabIndex        =   9
      TabStop         =   0   'False
      Top             =   630
      Width           =   7605
      Begin TextBox cFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "Data1"
         ForeColor       =   &H00000000&
         Height          =   285
         Index           =   0
         Left            =   1679
         TabIndex        =   12
         Top             =   0
         Visible         =   0   'False
         Width           =   3255
      End
      Begin CheckBox cFieldCheck
         BackColor       =   &H00C0C0C0&
         DataSource      =   "Data1"
         Height          =   330
         Index           =   0
         Left            =   1679
         TabIndex        =   11
         Top             =   735
         Visible         =   0   'False
         Width           =   3270
      End
      Begin PictureBox cFieldPicture
         DataSource      =   "Data1"
         Height          =   282
         Index           =   0
         Left            =   1679
         ScaleHeight     =   255
         ScaleWidth      =   3240
         TabIndex        =   10
         Top             =   315
         Visible         =   0   'False
         Width           =   3270
      End
      Begin Label cFieldName
         BackColor       =   &H00C0C0C0&
         ForeColor       =   &H00000000&
         Height          =   225
         Index           =   0
         Left            =   105
         TabIndex        =   13
         Top             =   0
         Visible         =   0   'False
         Width           =   1515
      End
   End
   Begin PictureBox FieldHeader
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   300
      Left            =   0
      ScaleHeight     =   300
      ScaleMode       =   0  'User
      ScaleWidth      =   8480.059
      TabIndex        =   6
      Top             =   330
      Width           =   8475
      Begin Label FieldValueLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   " Value:"
         Height          =   252
         Left            =   1680
         TabIndex        =   8
         Top             =   30
         Width           =   2652
      End
      Begin Label FieldHdrLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Field Name:"
         Height          =   252
         Left            =   120
         TabIndex        =   7
         Top             =   30
         Width           =   1212
      End
   End
   Begin PictureBox TopPic
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   330
      Left            =   0
      ScaleHeight     =   330
      ScaleWidth      =   8475
      TabIndex        =   0
      Top             =   0
      Width           =   8475
      Begin CommandButton RefreshBtn
         Caption         =   "&Refresh"
         Height          =   260
         Left            =   4680
         TabIndex        =   15
         Top             =   0
         Width           =   1215
      End
      Begin CommandButton FindBtn
         Caption         =   "&Find"
         Height          =   260
         Left            =   3480
         TabIndex        =   4
         Top             =   0
         Width           =   1215
      End
      Begin CommandButton DeleteBtn
         Caption         =   "&Delete"
         Height          =   260
         Left            =   2280
         TabIndex        =   3
         Top             =   0
         Width           =   1215
      End
      Begin CommandButton AddBtn
         Caption         =   "&Add"
         Height          =   260
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   1215
      End
      Begin CommandButton UpdateBtn
         Caption         =   "&Update"
         Height          =   260
         Left            =   1200
         TabIndex        =   1
         Top             =   0
         Width           =   1095
      End
   End
End
Dim FldArr() As control

Dim FDS As Dynaset
Dim numFlds As Integer
Dim CurrField As Integer
Dim JustUsedFind As Integer        'flag for find function
Dim fResizing As Integer           'flag to avoid resize recursion

Dim FldTop As Integer

Const EM_NOTHING = 0
Const EM_EDIT = 1
Const EM_ADDNEW = 2

Const FT_TRUEFALSE = 1
Const FT_BYTE = 2
Const FT_INTEGER = 3
Const FT_LONG = 4
Const FT_CURRENCY = 5
Const FT_SINGLE = 6
Const FT_DOUBLE = 7
Const FT_DATETIME = 8
Const FT_STRING = 10
Const FT_BINARY = 11
Const FT_MEMO = 12

Const YES = 6
Const MSGBOX_TYPE = 4 + 48

Sub AddBtn_Click ()
  On Error GoTo AddErr

    data1.Caption = "Entering New Record"
  If AddBtn.Tag = "Disabled" Then
    EnableAllControls
  End If
  data1.Recordset.AddNew
  FldArr(0).SetFocus
  Exit Sub

AddErr:
  MsgBox Error$
  Resume AddEnd
AddEnd:

End Sub

Sub cFieldPicture_Click (Index As Integer)
  'this toggles the size of a picture control
  'so it mat be viewed or compressed
  If cFieldPicture(Index).Height <= 280 Then
    cFieldPicture(Index).AutoSize = True
  Else
    cFieldPicture(Index).AutoSize = False
    cFieldPicture(Index).Height = 280
  End If
End Sub

Sub cFieldPicture_DblClick (Index As Integer)
  On Error GoTo PicErr

  st = InputBox("Enter Picture FilName:")
  If st <> "" Then
    cFieldPicture(Index).Picture = LoadPicture(st)
  End If

  GoTo PicEnd

PicErr:
  MsgBox Error$
  Resume PicEnd

PicEnd:

End Sub

Sub cScrollBar_Change ()
  Dim t As Integer

  t = cScrollBar
  If (t - FldTop) Mod 350 = 0 Then
    cFields.Top = t
  Else
    cFields.Top = ((t - FldTop) \ 350) * 350 + FldTop
  End If

End Sub

Sub Data1_Error (dataerr As Integer, response As Integer)
  If dataerr = 3021 Then
    response = 0
  ElseIf dataerr = 481 Or dataerr = 321 Then 'Invalid picture
    response = 0
  Else
    MsgBox "Error:  " + Error$(dataerr)
    response = 0
  End If
End Sub

Sub data1_Reposition ()
    'if not valid record and not in addnew mode
    If (data1.Recordset.BOF Or data1.Recordset.EOF) And data1.Caption <> "Entering New Record" Then
        DisableAllControls
    'otherwise, if form is disabled, then enable it
    ElseIf AddBtn.Tag = "Disabled" Then
        EnableAllControls
    Else
       If data1.Caption <> "Entering New Record" Then data1.Caption = "Editing Record"
    End If
End Sub

Sub Data1_Validate (Action As Integer, save As Integer)
On Error Resume Next
  'first check for a move from an addnew or edit record
  If Action < 5 Then
    If save = True Then      'data changed
      If data1.EditMode = EM_ADDNEW Then
        If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
          data1.UpdateRecord
          If Err <> 0 Then
            MsgBox Error$, 0, "Data Manager"
            Action = 0: save = 0
          End If
          save = 0
        Else
            save = 0
        End If
      ElseIf MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
         save = False        'loose changes
      End If
    End If
  data1.Caption = "Editing Record"
  End If

  Select Case Action
    Case 1          'First
    Case 6          'Update
      If save = True Then
        If data1.EditMode = EM_ADDNEW Then
          If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
            data1.UpdateRecord
            data1.Caption = "Editing Record"
          Else
            save = 0: Action = 0
          End If
        ElseIf MsgBox("Commit Changes?", MSGBOX_TYPE) = YES Then
          data1.UpdateRecord
        End If
      End If

    Case 10          'Close
      If save = True Then
        If MsgBox("Commit Changes before Closing?", MSGBOX_TYPE) = YES Then
        Else
          Cancel = True
        End If
      End If

  End Select


End Sub

Sub DeleteBtn_Click ()
  On Error GoTo DelErr

  If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then
    data1.Recordset.Delete
    data1.Recordset.MoveNext
    If AddBtn.Tag <> "Disabled" Then FldArr(0).SetFocus
  End If

  GoTo DelEnd

DelErr:
    If Err = 444 Then
        MsgBox "Can't delete this record.", 64, "Data Manager"
    ElseIf Err = 3021 Then
        DisableAllControls
    Else
        MsgBox Error$, 64, "Data Manager"
    End If
    If AddBtn.Tag <> "Disabled" Then FldArr(0).SetFocus
  Resume DelEnd

DelEnd:

End Sub

Sub DisableAllControls ()

    On Error GoTo disableerror
    'This handles the case of calls with empty tables before
    'call of loadfields.  Otherwise, you get subscript out of range.

   Dim i As Integer
   DeleteBtn.Enabled = False
   UpdateBtn.Enabled = False
'   FindBtn.Enabled = False
   For i = 0 To data1.Recordset.Fields.Count - 1
     FldArr(i).Visible = False
   Next i

    GoTo disableend
disableerror:
    Resume disableend
disableend:
   AddBtn.Tag = "Disabled"
   data1.Caption = "No Current Record"

End Sub

Sub EnableAllControls ()

   Dim i As Integer
   DeleteBtn.Enabled = True
   UpdateBtn.Enabled = True
'   FindBtn.Enabled = True

   For i = 0 To data1.Recordset.Fields.Count - 1
     FldArr(i).Visible = True
   Next i
   AddBtn.Tag = "Enabled"
   If data1.Caption <> "Entering New Record" Then
    data1.Caption = "Editing Record"
   End If
End Sub

Sub FindBtn_Click ()
  On Error GoTo FindErr
  Dim bm As String, findstr As String

  findstr = InputBox("Enter Search Expression:")
  If findstr = "" Then Exit Sub

  If Not data1.Recordset.BOF And Not data1.Recordset.EOF Then
    bm = data1.Recordset.Bookmark
  End If

  data1.Recordset.FindFirst findstr

  'return to old record if no match was found
  If data1.Recordset.NoMatch And bm <> "" Then
    data1.Recordset.Bookmark = bm
  End If

  GoTo FindEnd

FindErr:
  MsgBox Error$
  Resume FindEnd

FindEnd:
  If FldArr(0).Visible = True Then FldArr(0).SetFocus

End Sub

Sub Form_Load ()
  Dim ds2 As Dynaset

  On Error GoTo LoadErr

  '-------------------------------------------------------
  'this is where the data control properties get
  'set from whatever source they are coming from
  'in this case, it is mainform controls
  '-------------------------------------------------------
  Screen.MousePointer = 11 'wait cursor
  data1.DatabaseName = gDatabaseName
  data1.Connect = gDatabase.Connect
  Me.Caption = UCase(gDatabaseName) + " : " + UCase(mainForm.TableName)
  data1.RecordSource = mainForm.TableName
  '-------------------------------------------------------
  data1.Refresh

  LoadFields data1.Recordset, mainForm.TableName
  data1_Reposition 'This ensures that we enable the controls
  Me.Show
  If AddBtn.Tag = "Enabled" Then
    FldArr(0).SetFocus
  End If
  GoTo loadend
LoadErr:

  MsgBox Error$
  Unload Me
  Resume loadend

loadend:
  Screen.MousePointer = 0
End Sub

Sub Form_Resize ()
  On Error Resume Next

  If fResizing = True Then Exit Sub

  Dim h As Integer, i As Integer
  Dim totw As Integer

  fResizing = True
  If WindowState <> 1 And cFieldName(0).Visible = True Then 'not minimized
    'make sure the form is lined up on a field
    h = Height
    If (h - 1340) Mod 350 <> 0 Then
      Height = ((h - 1340) \ 350) * 350 + 1340
    End If
    'reset scroll
    If Height - 1340 >= cFields.Height - 1065 + 350 Then
        cScrollBar.Visible = False
    Else
        cScrollBar.Max = cScrollBar.Min + 350 * ((Height - 1340) \ 350) - (cFields.Height - 1065 + 350)
        cScrollBar.Visible = True
    End If
    'resize the status bar
    StatBox.Top = Height - 650
    'resize the scrollbar
    cScrollBar.Height = StatBox.Top - (FieldHeader.Top - FieldHeader.Height) - 600
    cScrollBar.Left = Width - 360
    If FDS.Fields.Count > 10 Then
      cFields.Width = Width - 260
      totw = cScrollBar.Left - 20
    Else
      cFields.Width = Width - 20
      totw = Width - 50
    End If
    FieldHeader.Width = Width - 20
    'widen the fields if possible
'    data1.Database.TableDefs(TableName).Fields.Refresh
'    For i = 0 To data1.Recordset.Fields.Count - 1
'      cFieldName(i).Width = .3 * totw
'       FldArr(i).Left = cFieldName(i).Width + 20
'      If data1.Recordset.Fields(i).Type > 9 Then
'        FldArr(i).Width = .7 * totw - 270
'      End If
'    Next
    FieldValueLabel.Left = FldArr(0).Left
  End If

  data1.Width = StatBox.Width
  fResizing = False

End Sub

Function GetFieldWidth (t As Integer)
  'determines the form control width
  'based on the field type
  Select Case t
    Case FT_TRUEFALSE
      GetFieldWidth = 850
    Case FT_BYTE
      GetFieldWidth = 650
    Case FT_INTEGER
      GetFieldWidth = 900
    Case FT_LONG
      GetFieldWidth = 1100
    Case FT_CURRENCY
      GetFieldWidth = 1800
    Case FT_SINGLE
      GetFieldWidth = 1800
    Case FT_DOUBLE
      GetFieldWidth = 2200
    Case FT_DATETIME
      GetFieldWidth = 2000
    Case FT_STRING
      GetFieldWidth = 3250
    Case FT_MEMO
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select

End Function

Sub LoadFields (t As Dynaset, tName)

'   Dim t As table
   Dim ft As Integer
   Dim i As Integer

   On Error GoTo LoadFieldsErr

'   Set t = db.OpenTable(tName)

   'load the controls on the dynaset form
   numFlds = t.Fields.Count

    If numFlds = 0 Then
        MsgBox "There are no fields in this table.  Cannot Edit Table Data", 64, "Data Manager"
        Unload Me
    End If

   ReDim FldArr(numFlds) As control
   cFieldName(0).Visible = True
   ft = t.Fields(0).Type
   If ft = FT_TRUEFALSE Then
     Set FldArr(0) = cFieldCheck(0)
   ElseIf ft = FT_BINARY Then
     Set FldArr(0) = cFieldPicture(0)
   Else
     Set FldArr(0) = cFieldData(0)
   End If
   FldArr(0).Visible = True
   FldArr(0).Top = 0
   FldArr(0).Width = GetFieldWidth(ft)
   FldArr(0).TabIndex = 0

   On Error Resume Next
   For i = 1 To t.Fields.Count - 1
     cFields.Height = cFields.Height + 350
     Load cFieldName(i)
     cFieldName(i).Top = cFieldName(i - 1).Top + 350
     cFieldName(i).Visible = True
     ft = t.Fields(i).Type
     If ft = FT_TRUEFALSE Then
       Load cFieldCheck(i)
       Set FldArr(i) = cFieldCheck(i)
     ElseIf ft = FT_BINARY Then
       Load cFieldPicture(i)
       Set FldArr(i) = cFieldPicture(i)
     Else
       Load cFieldData(i)
       Set FldArr(i) = cFieldData(i)
     End If
     FldArr(i).Top = FldArr(i - 1).Top + 350
     FldArr(i).Width = GetFieldWidth(ft)
     FldArr(i).TabIndex = i
   Next
   AddBtn.Tag = "Disabled"

   On Error GoTo LoadFieldsErr

   'resize main window
   cFields.Top = FieldHeader.Top + FieldHeader.Height
   FldTop = cFields.Top
   cScrollBar.Min = FldTop
   If i <= 10 Then
     Height = i * 350 + 1500
     cScrollBar.Visible = False
   Else
     Height = 5000
     Width = Width + 260
     cScrollBar.Visible = True
     cScrollBar.Max = FldTop - (i * 350) + 3500
     cScrollBar = FldTop
   End If

   'display the field names
   For i = 0 To t.Fields.Count - 1
     cFieldName(i) = UCase(t.Fields(i).Name) + ":"
   Next

   'bind the controls
   On Error Resume Next   'bind even if table is empty
   For i = 0 To t.Fields.Count - 1
     FldArr(i).DataField = t.Fields(i).Name
   Next

   GoTo LoadFieldsEnd

LoadFieldsErr:
   MsgBox Error$
   Resume LoadFieldsEnd

LoadFieldsEnd:

End Sub

Sub MoveBtn_Click (Index As Integer)
  On Error GoTo moveerr
  Dim bm As String

  If Not data1.Recordset.BOF And Not data1.Recordset.EOF Then
    bm = data1.Recordset.Bookmark
  End If
  Select Case Index
    Case 0
      If findval <> "" Then
        data1.Recordset.FindFirst findval
      Else
        data1.Recordset.MoveFirst
      End If
    Case 1
      If findval <> "" Then
        data1.Recordset.FindPrevious findval
      Else
        data1.Recordset.MovePrevious
      End If
    Case 2
      If findval <> "" Then
        data1.Recordset.FindNext findval
      Else
        data1.Recordset.MoveNext
      End If
    Case 3
      If findval <> "" Then
        data1.Recordset.FindLast findval
      Else
        data1.Recordset.MoveLast
      End If
  End Select
  'return to old record if no match was found
  If data1.Recordset.NoMatch And bm <> "" Then
    data1.Recordset.Bookmark = bm
  End If

  GoTo moveend

moveerr:
  MsgBox Error$
  Resume moveend

moveend:
  FldArr(0).SetFocus
End Sub

Sub RefreshBtn_Click ()
  data1.Refresh
End Sub

Sub UpdateBtn_Click ()
  On Error GoTo UpdErr

  data1.Recordset.Update

  GoTo UpdEnd
UpdErr:
  MsgBox Error$
  Resume UpdEnd

UpdEnd:

End Sub